home *** CD-ROM | disk | FTP | other *** search
/ Fritz: All Fritz / All Fritz.zip / All Fritz / FILES / PROGSCAL / TBUTIL2.LZH / QISORT.PAS < prev    next >
Pascal/Delphi Source File  |  1984-07-13  |  4KB  |  129 lines
  1. PROGRAM qsort(INPUT,OUTPUT);
  2. CONST max = 2000;   {max array size}
  3. TYPE standardarray = ARRAY[0..max] OF INTEGER;
  4. VAR  numbers: standardarray; {numeric array}
  5.      last:    INTEGER;
  6. PROCEDURE SWAP( VAR a,b: INTEGER );
  7. VAR t: INTEGER;
  8. BEGIN
  9.     t := a;
  10.     a := b;
  11.     b := t
  12. END;
  13. PROCEDURE getarray( VAR top : INTEGER ); {fill array from input}
  14. VAR index, maxnum: INTEGER;
  15.     temp:  INTEGER;
  16. BEGIN {getarray}
  17.     index := 0;
  18.     RANDOMIZE;
  19.     WRITE(' Number of integers: ');
  20.     READ(maxnum);
  21.     IF maxnum > max THEN maxnum := max;
  22.     WHILE index <= maxnum  DO
  23.         BEGIN
  24.             temp := RANDOM( index+1 );
  25.             numbers[index] := temp;
  26.             index := SUCC(index);
  27.         END;
  28.     WRITELN;
  29.     WRITELN( index-1:4, ' VALUES ENTERED' );
  30.     top := index - 2
  31. END; {getarray}
  32. PROCEDURE printarray( top: INTEGER ); {output array}
  33. VAR index: INTEGER;
  34. BEGIN {printarray}
  35.     FOR index := 0 TO top DO
  36.         BEGIN
  37.             IF index/4 = TRUNC(index/4) THEN WRITELN;
  38.             WRITE( numbers[index]:8 );
  39.         END
  40. END; {printarray}
  41. PROCEDURE bsort( start, top: INTEGER; VAR arry: standardarray );
  42. {bubble sort procedure. sorts array from start to top inclusive}
  43. VAR index:    INTEGER;
  44.     switched: BOOLEAN;
  45. BEGIN {bsort}
  46.     repeat
  47.          switched := FALSE;
  48.          FOR index := start TO top-1 DO
  49.              BEGIN
  50.                  IF arry[index] > arry[index+1] THEN
  51.                     BEGIN
  52.                         SWAP( arry[index], arry[index+1] );
  53.                         switched := TRUE;
  54.                     END
  55.              END;
  56.     UNTIL switched = FALSE;
  57. END; {bsort}
  58. PROCEDURE findmedian( start, top: INTEGER; VAR arry: standardarray );
  59. {procedure to find a good median value in array and place it}
  60. VAR middle: INTEGER;
  61.     sorted: standardarray;
  62. BEGIN {findmedian}
  63.     middle    := (start + top) DIV 2;
  64.     sorted[1] := arry[start];
  65.     sorted[2] := arry[top];
  66.     sorted[3] := arry[middle];
  67.     bsort( 1, 3, sorted );
  68.     IF sorted[2] = arry[middle] THEN
  69.        SWAP( arry[start], arry[middle] )
  70.     ELSE IF sorted[2] = arry[top] THEN
  71.        SWAP( arry[start], arry[top] );
  72. END; {findmedian}
  73. PROCEDURE sortsection( start, top: INTEGER; VAR arry: standardarray );
  74. {procedure to sort a section of the main array, and }
  75. {then divide it into two partitions to be sorted    }
  76. VAR swapup: BOOLEAN;
  77.     s,e,m:  INTEGER;
  78. BEGIN {sortsection}
  79.     IF top - start < 6 THEN {sort small sections with bsort}
  80.        bsort( start, top, arry )
  81.     ELSE
  82.        BEGIN
  83.            findmedian( start, top, arry );
  84.            swapup := TRUE;
  85.            {start scanning from array top}
  86.            s := start;  {lower comparison limit}
  87.            e := top;    {upper comparison limit}
  88.            m := start;  {location of comparison value}
  89.            WHILE e > s DO
  90.                BEGIN
  91.                    IF swapup = TRUE THEN
  92.                       {scan downward from partition top}
  93.                       {and exchange if smaller than median}
  94.                       BEGIN
  95.                           WHILE( arry[e] >= arry[m] ) AND (e > m)  DO
  96.                               e := e - 1;
  97.                           IF e > m THEN
  98.                              BEGIN
  99.                                  SWAP( arry[e], arry[m] );
  100.                                  m := e;
  101.                              END;
  102.                           swapup := FALSE;
  103.                       END
  104.                    ELSE
  105.                       {scan upward from a partition start}
  106.                       {and exchange if larger than median}
  107.                       BEGIN
  108.                           WHILE( arry[s] <= arry[m] ) AND (s < m) DO
  109.                               s := s + 1;
  110.                           IF s < m THEN
  111.                              BEGIN
  112.                                  SWAP( arry[s], arry[m] );
  113.                                  m := s;
  114.                              END;
  115.                           swapup := TRUE;
  116.                       END
  117.                END;
  118.            sortsection( start, m-1, arry ); {sort lower half of partition}
  119.            sortsection( m+1, top, arry );   {sort upper half of partition}
  120.            END
  121. END; {sortsection}
  122. BEGIN {qsort - main program}
  123.     getarray(last);
  124.     sortsection( 0, last, numbers );
  125.     printarray(last);
  126. END. {qsort}
  127.  
  128.  
  129.